home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / NUM2STR.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  3.0 KB  |  90 lines
  1. ; NUM2STR.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Number->String, Integer->String    & String->Number    *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: M. Meyer & T. Caudill    Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;* - 23 Dec 92: Added R^4 support: (number->string n),            *
  19. ;*    (string->number n) (lb)                        *
  20. ;*                                    *
  21. ;*                    ``In nomine omnipotentii dei''    *
  22. ;************************************************************************
  23.  
  24. (define (sprintf template . args)
  25.   (%execute (compile `(%esc 39 ,template ,@args))))
  26.  
  27. (define (sscanf string template)
  28.   (%esc 40 string template))
  29.  
  30. (define (string->number string . args)
  31.   (let* ((radix (if (null? args) 10 (car args)))
  32.      (s-radix (cdr (assoc radix '((2 . "#b")
  33.                       (8 . "#o")
  34.                       (10 . "#d")
  35.                       (16 . "#x")))))
  36.      (port (open-input-string
  37.          (string-append (if (null? s-radix)
  38.                     (error "string->number: invalid radix" radix)
  39.                     s-radix)
  40.                 string)))
  41.      (num (read port)))
  42.     (close-input-port port)
  43.     (if (number? num)
  44.     num
  45.     #F)))
  46.  
  47. (define (number->string number . args)
  48.   (if (cdr args) (error "number->string: 0 or 1 argument expected" args))
  49.   (let ((base (if (null? args)
  50.           10
  51.           (if (member (car args) '(2 8 10 16))
  52.               (car args)
  53.               (error "number->string: base expected" (car args))))))
  54.     (cond ((integer? number) (integer->string number base))
  55.       ((number? number) (if (= base 10)
  56.                 (sprintf "%g" number)
  57.                 (error "number->string: only base 10 for floats")))
  58.       (else (error "number->string: number expected" number)))))
  59.  
  60. (define (integer->string n base)
  61.   (cond ((< (abs base) 2) (%error-invalid-operand 'integer->string base))
  62.     ((and (negative? n) (positive? base))
  63.      (string-append "-" (integer->string (- n) base)))
  64.     ((zero? n) "0")
  65.     (else (let ((size (if (negative? base)
  66.                   (do ((s 0 (+ s 2))
  67.                    (base^2 (* base base))
  68.                    (base-1 (- -1 base))
  69.                    (x 0 (+ (* x base^2) base-1)))
  70.                   ((or (and (positive? n) (>= x n) (-1+ s))
  71.                        (and (negative? n) (<= (* x base) n) s))))
  72.                   (do ((s 1 (1+ s))
  73.                    (x base (* x base)))
  74.                   ((> x n) s))))
  75.             (base (abs base))
  76.             (next (if (negative? base)
  77.                   (lambda (n base) (- (divide n base)))
  78.                   divide)))
  79.         (do ((template (make-string size '())
  80.                    (let ((digit (modulo n base)))
  81.                  (string-set! template index
  82.                    (integer->char (+ digit
  83.                              (if (> digit 9)
  84.                              55 48))))
  85.                    ))
  86.              (index (-1+ size) (-1+ index))
  87.              (n n (next n base)))
  88.             ((= n 0) template))))))
  89.  
  90.